home *** CD-ROM | disk | FTP | other *** search
/ CD Ware Multimedia 1994 November / Cd Ware (Nro. 2) - Epimundo.iso / DOS / PG / PCXSCR.ZIP / PCXSCR.FOR < prev   
Encoding:
Text File  |  1994-06-14  |  5.7 KB  |  199 lines
  1.       subroutine printscreen(pcxname)
  2. c
  3. c This routine is called in graphics mode in order to dump
  4. c the whole screen into a .PCX file. The argument is the
  5. c name of the file to create, and is limited to 13 chars i.e.
  6. c intended to go in the current directory. 
  7. c I have only really stress-tested this in 16 colour mode,
  8. c 1 bit per pixel. I usually work in MAXRESMODE ....
  9. c
  10. c For 256 colour mode then the PCX file needs a different
  11. c method of storing the colourmap (i.e. at the end), which
  12. c is not covered here ...
  13. c
  14. c J.J.Bunn, 1994. Placed in the Public Domain, for what it's
  15. c worth. Please keep my name on it anyway!
  16. c
  17.       implicit integer(a-z)
  18.       include 'fgraph.fd'
  19.       logical fexists,nocompress
  20.       integer*1 buffer [allocatable] (:)
  21.       byte b,bt
  22.       integer*2 ic
  23.       character*13 pcxname
  24.       character*6 ctext
  25.       structure /PCX_header/
  26.        union
  27.         map
  28.          character*128 char
  29.         end map
  30.         map
  31.          byte manu
  32.          byte version
  33.          byte encoding
  34.          byte bitsPpixel
  35.          integer*2 xmin
  36.          integer*2 ymin
  37.          integer*2 xmax
  38.          integer*2 ymax
  39.          integer*2 hres
  40.          integer*2 vres
  41.          byte colormap(48)
  42.          byte reserved
  43.          byte nplanes
  44.          integer*2 bytesPline
  45.          integer*2 palette
  46.          byte filler(58)
  47.         end map
  48.        end union
  49.       end structure
  50.       record /videoconfig/ screen
  51.       record /PCX_header/ pcx
  52.       byte red(16),green(16),blue(16)
  53.       equivalence (bt,ic)
  54.       save red,green,blue
  55.       data red  /#00,#00,#00,#00,#A8,#A8,#A8,#A8,
  56.      & #54,#54,#54,#54,#FC,#FC,#FC,#FC/
  57.       data green/#00,#00,#A8,#A8,#00,#00,#54,#A8,
  58.      & #54,#54,#FC,#FC,#54,#54,#FC,#FC/
  59.       data blue /#00,#A8,#00,#A8,#00,#A8,#00,#A8,
  60.      & #54,#FC,#54,#FC,#54,#FC,#54,#FC/
  61. c
  62. c Setting nocompress = .true. will prevent run-length encoding
  63. c of the image byte stream ... not usually what we want!
  64. c
  65.       nocompress = .false.
  66.       inquire(file=pcxname,exist=fexists)
  67.       if(fexists) then
  68.          open(1,file=pcxname,status='old',
  69.      &        form='unformatted',recl=512,err=900)
  70.          close(1,status='delete')
  71.       endif
  72.       open(1,file=pcxname,status='new',access='direct',
  73.      &     form='binary',recl=1,err=900)
  74.       call getvideoconfig(screen)
  75.       width = screen.numxpixels
  76. c      colors = screen.numcolors
  77.       height = screen.numypixels
  78. c
  79. c Calls to "transient" are commented out. In my package,
  80. c transient is a routine that posts info messages in a
  81. c designated area of the screen.
  82. c
  83.       call transient('Patience please ... !')
  84.       call setviewport(0,0,width-1,height-1)
  85. c
  86. c I compress in 4 bands of y, since doing the whole
  87. c screen in one go can exhaust the memory too easily.
  88. c npass could be calculated from free memory ....
  89. c
  90.       npass = 4
  91.       ipass = 0
  92.       iyband = height/npass - 1
  93.       iyhigh = -1
  94.  100  ipass = ipass + 1
  95.       iylow = iyhigh + 1
  96.       iyhigh = min(iylow + iyband,height-1)
  97.  
  98.       imsize = imagesize(0,iylow,width-1,iyhigh)
  99.       if(ipass.eq.1) then
  100. c
  101. c first band .. allocate the buffer
  102. c
  103.          if(allocated(buffer)) deallocate(buffer)
  104.          allocate(buffer(imsize), stat=error)
  105.          if(error.ne.0) goto 910
  106.       endif
  107.       call getimage(0,iylow,width-1,iyhigh,buffer)
  108.       if(ipass.eq.1) then
  109. c
  110. c create the PCX header and write it out
  111. c
  112.          pcx.manu = 10           
  113.          pcx.version = 5
  114.          pcx.encoding = 1
  115.          pcx.xmin = 0
  116.          pcx.xmax = width-1
  117.          pcx.ymin = 0
  118.          pcx.ymax = height-1
  119.          pcx.hres = width
  120.          pcx.vres = height
  121. c
  122. c I've hard coded the 16 colour values here ...
  123. c this would require changing for 256 colours.
  124. c
  125.          do i=1,16
  126.             pcx.colormap(3*i-2) = red(i)
  127.             pcx.colormap(3*i-1) = green(i)
  128.             pcx.colormap(3*i) = blue(i)
  129.          end do
  130.          do i=1,58
  131.             pcx.filler(i) = 0
  132.          end do
  133. c
  134. c should be calculated from screen.numcolors ...
  135. c
  136.          pcx.nplanes = 4
  137.          pcx.bitsPpixel = 1
  138.          pcx.bytesPline = width *pcx.bitsPpixel/8
  139.          pcx.palette = 1
  140.          write(1) pcx.char
  141. c PCX header length ... data follow
  142.          nout = 128   
  143.          widbyte = pcx.bytesPline*pcx.nplanes
  144.       endif
  145. c
  146. c first four bytes are info
  147. c
  148.       ipos = 5
  149. c
  150. c run length encode the bytes ...
  151. c
  152.     2 if(ipos.gt.imsize) goto 5
  153.       b = buffer(ipos)
  154.       icount = 1
  155.       if(nocompress) goto 4
  156.       endscan = (ifix((ipos-5)/widbyte) + 1)*widbyte
  157.       endscan = min(imsize,endscan+4)
  158.       if(ipos.eq.endscan) goto 4
  159.       do 3 i=ipos+1,endscan
  160.          if(buffer(i).ne.b) goto 4
  161.          if(icount.ge.#3F) goto 4
  162.          icount = icount + 1
  163.     3 continue
  164.     4 continue
  165.       ipos = ipos + icount
  166.       if(icount.ne.1.or.(b.and.#C0).ne.0) then
  167. c
  168. c if there is more than one byte the same, or one or both of
  169. c the top two bits of the current byte is set, write the count byte
  170. c and the data byte
  171. c
  172.          ic = icount .or. #C0   ! bt is equivalenced to this
  173.          write(1) bt
  174.          write(1) b
  175.          nout = nout + 2
  176.       else
  177. c
  178. c the byte is a singleton, and neither of the two top bits is
  179. c set
  180. c
  181.          write(1) b
  182.          nout = nout + 1
  183.       endif
  184.       goto 2
  185.     5 if(ipass.lt.npass) goto 100
  186. c      write(ctext,'(i6)') nout
  187. c      call transient(ctext//' bytes written to '//pcxname//' OK!')
  188.       close(1)
  189.       goto 1000
  190.   900 continue
  191. c      call transient('Cannot open PCX file for writing !')
  192.       goto 1000
  193.   910 continue
  194. c      call transient('Insufficient memory for screen dump, sorry.')
  195.       if(ipass.gt.1) close(1,status='delete')
  196.  1000 continue
  197.       if(allocated(buffer)) deallocate(buffer)
  198.       end
  199.